home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #2
/
Monster Media No. 2 (Monster Media)(1994).ISO
/
prog_gen
/
qshade.zip
/
TSHADE.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1994-06-04
|
12KB
|
427 lines
(*
──────────────────────
Quick Shade unit v1.0
──────────────────────
(c)1994 Rsc Research
Write me at: or on Compuserve
──────────── ────────────────
Cédric Rime 100340,2736
Dixence 21
1950 Sion
Switzerland
This program is entered as Shareware.
If you find it useful, a small donation would be appreciated.(then i can take some English lessons!!!)
Feel free to incorporate the code into your own programs.
*)
{$F-}
{$N+}
{$E+}
{$D-}
{$L-}
{$Y-}
UNIT Tshade;
INTERFACE
{$define pointperface=3}
USES drawpoly,crt,tools;
TYPE points=RECORD
x,y,z:real;
END;
patchs=RECORD
s1,s2,s3:WORD;
col:BYTE;
END;
CONST MaxP=1500; (*Max points in world*)
VAR pnt:ARRAY[1..MaxP] OF points;
pat:ARRAY[1..MaxP] OF patchs;
dwg:ARRAY[1..MaxP] OF pt;
zbuffering:ARRAY[1..MaxP] OF real;
sort:ARRAY[1..MaxP] OF WORD;
pacount:WORD; (*Patch in drawing*)
pocount:WORD; (*Points in drawing*)
midx,midy:INTEGER; (*Screen Center coord. = Drawing center*)
Light1,Light2:INTEGER; (*2 points for light direction*)
LightPat:INTEGER; (*1 patch for light drawing*)
LightRadius:real; (*Length for Light drawing*)
LightColor:BYTE; (*What's color*)
LightFactor:real; (*Light Factory*)
LightAmbient:BYTE; (*Light Ambient*)
FrontClip:real; (*Minimal value for front clipping*)
PROCEDURE InitShade; (*Sort All Points on Z axis*)
PROCEDURE AddLight; (*Show LightPosition*)
PROCEDURE redraw; (*Redraw Picture, use double buffering*)
PROCEDURE Clear; (*Clean drawing*)
FUNCTION AddPoint(x,y,z:real):INTEGER; (*Add a point in drawing*)
PROCEDURE AddPatch(s1,s2,s3:INTEGER;co:BYTE); (*Add a patch on 3 points*)
PROCEDURE move_center(orgx,orgy,orgz:real); (*Move Drawing*)
PROCEDURE gravity(VAR xx,yy,zz:real); (*Calc gravity center*)
PROCEDURE calc(ax,ay,az,dist:real); (*Rotate drawing on AX&AY angle, AZ=focus DIST=distance*)
PROCEDURE xshade(sun_a,sun_b,sun_c:real); (*Quick Shading on XYZ axis*)
PROCEDURE shadepalette(faca,facb,facc:real;baseR,BaseG,BaseB:BYTE);
(*Smooth palette, Factor for R,G,B, Base for R,G,B*)
PROCEDURE LoadMesh(nom:STRING;scalex,scaley,scalez:real;col:BYTE);
(*Import Ascii meshes from 3D Studio or ...*)
PROCEDURE Pop;PROCEDURE push; (*Used into LoadMesh*)
IMPLEMENTATION
(*########################################################################*)
PROCEDURE gravity(VAR xx,yy,zz:real);
VAR q:INTEGER;
BEGIN
xx:=0;yy:=0;zz:=0;
FOR q:=1 TO pocount DO BEGIN xx:=xx+pnt[q].x;yy:=yy+pnt[q].y;zz:=zz+pnt[q].z;END;
xx:=xx/pocount;yy:=yy/pocount;zz:=zz/pocount;
END;
(*########################################################################*)
FUNCTION ztest(r:real):real; (*If R=0 then return=0.0001*)
BEGIN
IF r=0 THEN ztest:=0.0001 ELSE ztest:=r;
END;
(*########################################################################*)
PROCEDURE InitShade;
VAR q,w:INTEGER;
dummy:INTEGER;
dummy2:BYTE;
PROCEDURE Swap(n1,n2:BYTE);
BEGIN
IF n1>n2 THEN BEGIN Dummy2:=n1;n1:=n2;n2:=dummy2;END;
IF (n1=1) AND (n2=2) THEN BEGIN dummy:=pat[q].s1;pat[q].s1:=pat[q].s2;pat[q].s2:=dummy;EXIT;END;
IF (n1=1) AND (n2=3) THEN BEGIN dummy:=pat[q].s1;pat[q].s1:=pat[q].s3;pat[q].s3:=dummy;EXIT;END;
IF (n1=2) AND (n2=3) THEN BEGIN dummy:=pat[q].s2;pat[q].s2:=pat[q].s3;pat[q].s3:=dummy;EXIT;END;
END;
BEGIN
FOR q:=1 TO pacount DO
BEGIN
IF pnt[pat[q].s1].z<pnt[pat[q].s2].z THEN Swap(1,2);
IF pnt[pat[q].s1].z<pnt[pat[q].s3].z THEN Swap(1,3);
IF pnt[pat[q].s2].z<pnt[pat[q].s3].z THEN Swap(2,3);
END;
END;
(*########################################################################*)
PROCEDURE AddLight;
BEGIN
Light1:=addpoint(0,0,0);
Light2:=addpoint(0,0,0);
Addpatch(light1,light2,light2,LightColor);
LightPat:=pacount;
END;
(*########################################################################*)
PROCEDURE redraw;
VAR q2,q1:INTEGER;
fa:ARRAY[1..3] OF pt;
BEGIN
vscls;
FOR q2:=1 TO Pacount DO WITH dwg[q1] DO BEGIN
q1:=sort[q2];
fa[1]:=dwg[pat[q1].s1];
fa[2]:=dwg[pat[q1].s2];
fa[3]:=dwg[pat[q1].s3];
tri(fa,pat[q1].col);
END;
vsshow;
END;
(*########################################################################*)
PROCEDURE move_center(orgx,orgy,orgz:real);
VAR q:INTEGER;
BEGIN
FOR q:=1 TO pocount DO pnt[q].x:=pnt[q].x-orgx;
FOR q:=1 TO pocount DO pnt[q].y:=pnt[q].y-orgy;
FOR q:=1 TO pocount DO pnt[q].z:=pnt[q].z-orgz;
END;
(*########################################################################*)
PROCEDURE SetRGBPalette(co,r,g,b:BYTE);
BEGIN
Port[$3C8] := Co;
Port[$3C9] := R;
Port[$3C9] := G;
Port[$3C9] := B;
END;
(*########################################################################*)
PROCEDURE shadepalette(faca,facb,facc:real;baseR,BaseG,BaseB:BYTE);
VAR q:INTEGER;
BEGIN
IF faca=0 THEN faca:=0.00001;
IF facb=0 THEN facb:=0.00001;
IF facc=0 THEN facc:=0.00001;
faca:=faca/100*(63-baseR)/255;
facb:=facb/100*(63-baseG)/255;
facc:=facc/100*(63-baseB)/255;
FOR q:=1 TO 255 DO setrgbpalette(q,BaseR+Trunc(q*faca),BaseG+Trunc(q*facb),BaseB+Trunc(q*facc));
END;
(*########################################################################*)
PROCEDURE xshade(sun_a,sun_b,sun_c:real);
VAR e,q,w:INTEGER;
ang1,ang2:real;
xu,yu,zu,xv,yv,zv,xn,y0n,zn,v1,v2,v3,v4,v5,xw,yw,zw:real;
BEGIN
sun_a:=sun_a/57.29;
sun_b:=sun_b/57.29;
sun_c:=sun_c/57.29;
FOR q:=1 TO pacount DO WITH pat[q] DO BEGIN
xu := pnt[s2].x -pnt[s1].x ;yu := pnt[s2].y -pnt[s1].y ;zu := pnt[s2].z -pnt[s1].z ; (* vector 1 a 2 *)
xv := pnt[s3].x -pnt[s1].x ;yv := pnt[s3].y -pnt[s1].y ;zv := pnt[s3].z -pnt[s1].z ; (* vector 1 a 3 *)
xn := (yu *zv )-(zu *yv );
y0n := (zu *xv )-(xu *zv );
zn := (xu *yv )-(yu *xv ); (* Vecteur perpendiculaire a la surface*)
y0n := y0n *(-1);
zn := zn *(-1);
v1 := (xn *xn )+(y0n *y0n )+(zn *zn );
v2 := Sqrt (v1 ); (* magnitude*)
IF v2=0 THEN v2:=0.00001;
v3 := v2;
xw := v3 *xn ;yw := v3 *y0n ;zw := v3 *zn ;
v4 := (xw *sun_a )+(yw *sun_b )+(zw *sun_c ); (* illumination facteur 0 to 1 *)
v4 := v4/LightFactor+LightAmbient; (* facteur d'illumination*)
IF v4>255 THEN v4:=255;
IF v4<LightAmbient THEN v4:=lightAmbient;
col:=Trunc(v4);
END;
IF light1<>-1 THEN
BEGIN (*If ADDLIGHT was used*)
pnt[light1].x:=ztest(Sin(-sun_A)*LightRadius);
pnt[light1].y:=ztest(Sin(-sun_B)*LightRadius);
pnt[light1].z:=ztest(Sin(-sun_C)*LightRadius);
pnt[light2].x:=ztest(Sin(-sun_A)*LightRadius/2);
pnt[light2].y:=ztest(Sin(-sun_B)*LightRadius/2);
pnt[light2].z:=ztest(Sin(-sun_C)*LightRadius/2);
pat[LightPat].col:=LightColor;
END;
END;
(*########################################################################*)
PROCEDURE calc(ax,ay,az,dist:real);
VAR q,w:INTEGER;
aux1,aux2,aux3,aux4,aux5,aux6,aux7,aux8:real;
x_obs,y_obs,z_obs:real;
sum:ARRAY[1..MaxP] OF real;
sum_old:real;
e:WORD;
PROCEDURE init_projection(the,phi:real);
VAR th,ph:real;
BEGIN
th:=the*0.017454;ph:=phi*0.017454;
aux1:=Sin(th);aux2:=Sin(ph);aux3:=Cos(th);aux4:=Cos(ph);
aux5:=aux3*aux2;aux6:=aux1*aux2;aux7:=aux3*aux4;aux8:=aux1*aux4;
END;
PROCEDURE QuickSort;
VAR Lo,Hi:INTEGER;
i, j : INTEGER;
x,y:real;
v:INTEGER;
PROCEDURE qSort(l, r: INTEGER);
BEGIN
i := l; j := r; x := sum[(l+r) DIV 2];
REPEAT
WHILE sum[i] < x DO i := i + 1;
WHILE x < sum[j] DO j := j - 1;
IF i <= j THEN
BEGIN
y := sum[i]; sum[i]:= sum[j]; sum[j]:=y;
v := sort[i];sort[i]:=sort[j];sort[j]:=v;
i := i + 1; j := j - 1;
END;
UNTIL i > j;
IF l < j THEN qSort(l, j);
IF i < r THEN qSort(i, r);
END;
BEGIN {QuickSort};
Lo:=1;Hi:=Pacount;
qSort(Lo,Hi);
END;
BEGIN
init_projection(ax,ay);
FOR q:=1 TO pocount DO BEGIN
x_obs:=-pnt[q].x*aux1+pnt[q].y*aux3;
y_obs:=-pnt[q].x*aux5-pnt[q].y*aux6+pnt[q].z*aux4;
z_obs:=-pnt[q].x*aux7-pnt[q].y*aux8-pnt[q].z*aux2+az;
dwg[q].x:=midx+Trunc(dist*x_obs/(z_obs));
dwg[q].y:=midy+Trunc(dist*y_obs/(z_obs));
zbuffering[q]:=(z_obs-az) /10;
END;
FOR q:=1 TO pacount DO WITH pat[q] DO
sum[q]:=(zbuffering[s1]+zbuffering[s2]+zbuffering[s3]); (*must be more accurate*)
FOR q:=1 TO pacount DO sort[q]:=q;
quicksort;
END;
(*########################################################################*)
PROCEDURE Clear;
BEGIN
pocount:=0;
pacount:=0;
END;
(*########################################################################*)
FUNCTION AddPoint(x,y,z:real):INTEGER;
BEGIN
IF pocount>=MaxP THEN EXIT;
INC(pocount);
IF x=0 THEN x:=0.0001;
IF y=0 THEN y:=0.0001;
IF z=0 THEN z:=0.0001;
Pnt[pocount].x:=x;
Pnt[pocount].y:=y;
Pnt[pocount].z:=z;
Addpoint:=pocount;
END;
(*########################################################################*)
VAR old:INTEGER;
PROCEDURE AddPatch(s1,s2,s3:INTEGER;co:BYTE);
BEGIN
IF pacount>=MaxP THEN EXIT;
INC(pacount);
Pat[pacount].s1:=s1+old;
Pat[pacount].s2:=s2+old;
Pat[pacount].s3:=s3+old;
Pat[pacount].col:=co;
END;
(*########################################################################*)
PROCEDURE Push;
BEGIN
old:=Pocount;
END;
PROCEDURE Pop;
BEGIN
old:=0;
END;
(*########################################################################*)
(*With LOADMESH, you will load an ASCII mesh file, ge. 3d Studio,...*)
PROCEDURE LoadMesh(nom:STRING;scalex,scaley,scalez:real;col:BYTE);
VAR f:TEXT;
x,y,z:real;
p1,p2,p3,p4:INTEGER;
a,s,lin:STRING;
q:INTEGER;
FUNCTION GetWord(VAR st:STRING):STRING;
VAR q,w:INTEGER;
a:STRING;
BEGIN
IF Length(st)<2 THEN BEGIN GetWord:='';EXIT;END;
IF st[1]=' ' THEN
BEGIN
REPEAT
Delete(st,1,1);
UNTIL (st[1]<>' ') OR (Length(st)<1);
END;
a:='';
REPEAT
a:=a+st[1];
Delete(st,1,1);
UNTIL (st[1]=' ') OR (Length(st)<1);
GetWord:=a;
END;
BEGIN
push;
Assign(f,nom);
{$i-}
Reset(f);
REPEAT
ReadLn(f,lin);lin:=toupper(lin);a:=lin;
s:=getword(a);
IF s='NAMED' THEN push;
IF s='VERTEX' THEN
IF Copy(getword(a),1,4)<>'LIST' THEN
BEGIN
getword(a);
Val(getword(a),x,q);
getword(a);
Val(getword(a),y,q);
getword(a);
Val(getword(a),z,q);
addpoint(x*scalex,y*scaley,z*scalez);
END;
IF s='FACE' THEN
IF Copy(getword(a),1,4)<>'LIST' THEN
BEGIN
s:=getword(a);
p1:=1+ival(Copy(s+' ',3,Length(s)-2));
s:=getword(a);
p2:=1+ival(Copy(s+' ',3,Length(s)-2));
s:=getword(a);
p3:=1+ival(Copy(s+' ',3,Length(s)-2));
Addpatch(p1,p2,p3,col);
END;
(*writeln(pocount:4,pacount:4,lin);*)
pop;
UNTIL Eof(f);
Close(f);
END;
(*########################################################################*)
(*########################################################################*)
(*########################################################################*)
BEGIN
midx:=Round(160);
midy:=Round(100);
FrontClip:=-100;
Pocount:=0;Pacount:=0;push;
LightFactor:=10;
Light1:=-1;
LightColor:=255;Lightpat:=-1;
LightAmbient:=1;
LightRadius:=50;
END.